home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / bfl / bfl.lha / cfortex.for < prev    next >
Text File  |  1992-10-28  |  9KB  |  359 lines
  1. C cfortex.f
  2. C Burkhard Burow, burow@vxdesy.cern.ch, University of Toronto, 1992. 
  3.  
  4. C NAG f90 only
  5. C Uses an exclamation mark, '!', to start comments. Do:
  6. C prompt> mv cfortex.f cf_temp.f &&sed 's/^C/\!/g' cf_temp.f >cfortex.f
  7. C      to convert the comments here into f90 compliant ones.
  8. C NAG f90 only
  9.  
  10.       subroutine ss1(b)
  11.       character*(*) b
  12.       character*(13) a
  13.       data a/'first'/
  14.       b = a
  15.       return
  16.       end
  17.  
  18.       subroutine abc(a,b,c)
  19.       character*(*) b,a,c
  20.       character*(13) d
  21.       d = a
  22.       a = b
  23.       b = c
  24.       c = d
  25.       return
  26.       end
  27.  
  28.       subroutine forstr1(b)
  29.       character*(*) b
  30.       character*(13) a
  31.       character*(13) forstr
  32.       data a/'firs'/
  33.       b = forstr(a)
  34.       return
  35.       end
  36.  
  37.  
  38.       subroutine EASY(a,b)
  39.       integer a,b
  40.       a = b
  41.       return
  42.       end
  43.  
  44.       character*(*) function forstr(a)
  45.       character*(*) a
  46.       forstr = a
  47.       return
  48.       end
  49.  
  50.       function rr(i)
  51.       rr = i
  52.       return
  53.       end
  54.  
  55.       character*(*) function forstr2()
  56. C      character*(13) a   VAX/Ultrix complains about these ().
  57.       character*13 a
  58.       data a/'first'/
  59.       forstr2 = a
  60.       return
  61.       end
  62.  
  63.       character*(*) function ft(v, w, a)
  64.       character *(*) v(4), w(4)
  65.       print*,'FT:len(v(1 or 2 or 3 or 4))  =',len(v(1))
  66.       print*,'FT:len(w(1 or 2 or 3))    =',len(w(1))
  67.       print*,'FT:a = ',a
  68.       print*,'FT:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
  69.       print*,'FT:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4)
  70.       ft = v(1)
  71.       return
  72.       end
  73.  
  74.       character*(*) function fz(v, w, i)
  75.       character *(*) v(i), w(i)
  76.       print*,'FZ:len(v(1 or 2 or 3 or 4))  =',len(v(1))
  77.       print*,'FZ:len(w(1 or 2 or 3))    =',len(w(1))
  78.       do 100 j = 1,i
  79.         print*,'FZ:v(',j,') =',v(j),'   w(',j,') =',w(j)
  80. 100   continue
  81.       fz = v(1)
  82.       return
  83.       end
  84.  
  85.       subroutine sz(v, w, i)
  86.       character *(*) v(i), w(i)
  87.       print*,'SZ:len(v(1 or 2 or 3 or 4))  =',len(v(1))
  88.       print*,'SZ:len(w(1 or 2 or 3))    =',len(w(1))
  89.       do 100 j = 1,i
  90.         print*,'SZ:v(',j,') =',v(j),'   w(',j,') =',w(j)
  91. 100   continue
  92.       return
  93.       end
  94.  
  95.       subroutine subt(v, w, a)
  96.       character *(*) v(4), w(4)
  97.       print*,'SUBT:len(v(1 or 2 or 3 or 4))  =',len(v(1))
  98.       print*,'SUBT:len(w(1 or 2 or 3))    =',len(w(1))
  99.       print*,'SUBT:a = ',a
  100.       print*,'SUBT:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
  101.       print*,'SUBT:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4)
  102.       return
  103.       end
  104.  
  105.       subroutine rev(a)
  106.       integer a(2),t
  107.       t    = a(1)
  108.       a(1) = a(2)
  109.       a(2) = t
  110.       return
  111.       end
  112.  
  113.       integer function frev(a)
  114.       integer a(2)
  115.       frev = a(1)
  116.       a(1) = a(2)
  117.       a(2) = frev
  118.       return
  119.       end
  120.  
  121.       subroutine ffcb()
  122.       common /fcb/  v,w,x
  123.       character *(13) v, w(4), x(3,2)
  124.       print*,'FFCB:v =',v,'.'
  125.       print*,'FFCB:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4),'.'
  126.       print*,'FFCB:x([1,2,3],1) =',x(1,1),',',x(2,1),',',x(3,1),'.'
  127.       print*,'FFCB:x([1,2,3],2) =',x(1,2),',',x(2,2),',',x(3,2),'.'
  128.       v      = 'fcb v'
  129.       w(1)   = 'fcb w(1)'
  130.       w(2)   = 'fcb w(2)'
  131.       w(3)   = 'fcb w(3)'
  132.       x(1,1) = 'fcb x(1,1)'
  133.       x(2,1) = 'fcb x(2,1)'
  134.       x(3,1) = 'fcb x(3,1)'
  135.       x(1,2) = 'fcb x(1,2)'
  136.       x(2,2) = 'fcb x(2,2)'
  137.       x(3,2) = 'fcb x(3,2)'
  138.       end
  139.  
  140.       subroutine feq()
  141.       parameter (kwbank=690)  
  142. C The & in the next line is for f90 line continuation.
  143. C It is in column 74, i.e. part of f77 comments.
  144.       common/gcbank/nzebra,gversn,zversn,ixstor,ixdiv,ixcons,fendq(16)   &
  145.      &             ,lmain,lr1,ws(kwbank)    
  146.       dimension iq(2),q(2),lq(80),iws(2)  
  147.       equivalence (q(1),iq(1),lq(9)),(lq(1),lmain) ,(iws(1),ws(1))
  148.       nzebra     = 1
  149.       gversn     = 2
  150.       zversn     = 3
  151.       ixstor     = 4
  152.       ixcons     = 5
  153.       fendq(16)  = 6
  154.       lmain      = 7
  155.       lr1        = 8
  156.       ws(kwbank) = 9
  157.       lq(9)      = 10
  158.       end
  159.  
  160.       subroutine fexist()
  161.       print*,'FEXIST: was called'
  162.       call exist()
  163.       return
  164.       end
  165.  
  166.       subroutine fa(i)
  167.       integer i
  168.       print*,'FA: integer argument =',i
  169.       call cfortranca(i)
  170.       return
  171.       end
  172.  
  173.       subroutine fb(i)
  174.       integer i
  175.       print*,'FB: integer argument =',i
  176.       i = i*2
  177.       call cfcb(i)
  178.       return
  179.       end
  180.  
  181.       subroutine fc(b)
  182.       character*(*) b
  183.       print*,'FC: string argument =',b
  184.       call cfcc(b)
  185.       return
  186.       end
  187.  
  188.       subroutine fd(b)
  189.       character*(*) b
  190.       character*(13) a
  191.       data a/'birthday'/
  192.       b = a
  193.       call cdcfort(b)
  194.       return
  195.       end
  196.  
  197.       subroutine fe(v)
  198.       character*(*) v(4)
  199.       print*,'FE:len(v(1 or 2 or 3 or 4))  =',len(v(1))
  200.       print*,'FE:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
  201.       call ce(v)
  202.       return
  203.       end
  204.  
  205.       subroutine ff(v,n)
  206.       character*(*) v(4)
  207.       print*,'FF:len(v(1 or 2 or 3 or 4))  =',len(v(1))
  208.       print*,'FF:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
  209.       print*,'FF:n =',n
  210.       call ccff(v,n)
  211.       return
  212.       end
  213.  
  214.       integer function fg()
  215.       integer ccg
  216.       fg = ccg()
  217.       return
  218.       end
  219.  
  220.       character*(*) function fh()
  221.       character*200 cch
  222.       fh = cch()
  223.       return
  224.       end
  225.  
  226.       character*(*) function fi(v)
  227.       character*(*) v(6)
  228.       character*200 ci
  229.       fi = ci(v)
  230.       return
  231.       end
  232.  
  233.       character*(*) function fj(v)
  234.       integer v
  235.       character*200 cj
  236.       print*,'FJ:v =',v
  237.       fj = cj(v)
  238.       return
  239.       end
  240.  
  241.       real function fk()
  242.       real ck
  243.       fk = ck()
  244.       return
  245.       end
  246.  
  247.       double precision function fl()
  248.       double precision cl
  249.       fl = cl()
  250.       return
  251.       end
  252.  
  253.       real function fm(r)
  254.       real cm
  255.       fm = cm(r)
  256.       return
  257.       end
  258.  
  259.       double precision function fn(a,b)
  260.       double precision cn,a,b
  261.       fn = cn(a,b)
  262.       return
  263.       end
  264.  
  265.       logical function fand(a,b)
  266.       logical cand,a,b
  267.       fand = cand(a,b)
  268.       return
  269.       end
  270.  
  271.  
  272.       logical function forr(a,b)
  273.       logical cor,a,b
  274.  
  275.       print *, 'FORTRAN thinks you called forr(a=',a,',b=',b,').'
  276.       forr = cor(a,b)
  277.       print *, 'FORTRAN thinks cor(a,b) returned with a=',a,',b=',b,').'
  278.  
  279.       if (a.eqv..true.)then
  280.         print *,'Double check: a is true:',a
  281.       endif
  282.       if (a.eqv..false.)then
  283.         print *,'Double check: a is false:',a
  284.       endif
  285.       if (.not.((a.eqv..false.) .or. (a.eqv..true.))) then
  286.         print *,'Double check: ERROR: a is neither true nor false:',a
  287.         print *,'  Please contact burow@vxdesy.cern.ch.'
  288.       endif
  289.  
  290.       if (b.eqv..true.)then
  291.         print *,'Double check: b is true:',b
  292.       endif
  293.       if (b.eqv..false.)then
  294.         print *,'Double check: b is false:',b
  295.       endif
  296.       if (.not.((b.eqv..false.) .or. (b.eqv..true.))) then
  297.         print *,'Double check: ERROR: b is neither true nor false:',b
  298.         print *,'  Please contact burow@vxdesy.cern.ch.'
  299.       endif
  300.  
  301. C      print *, ' '
  302. C      print *, '   Testing non-FORTRAN/77 (b .eq. .true.) which'
  303. C      print *, '    will not compile on NAG f90 or Apollo or IBM RS/6000.'
  304. C      print *, '   Compile cfortest.c with LOGICAL_STRICT defined'
  305. C      print *, '    if you wish this test to work as expected.'
  306. C      print *, '   This test requires a and b to match the internal '
  307. C      print *, '    representation of .TRUE. and .FALSE. exactly.'
  308. C      if (a.eq..true.)then
  309. C        print *,'Representation check: a matches .true.'
  310. C      endif
  311. C      if (a.eq..false.)then
  312. C        print *,'Representation check: a matches .false.'
  313. C      endif
  314. C      if (.not.(a.eq..false. .or. a.eq..true.)) then
  315. C        print *,'Representation check:  '
  316. C        print *,'         a matches neither .true. nor .false.'
  317. C      endif
  318. C      if (b.eq..true.)then
  319. C        print *,'Representation check: b matches .true.'
  320. C      endif
  321. C      if (b.eq..false.)then
  322. C        print *,'Representation check: b matches .false.'
  323. C      endif
  324. C      if (.not.(b.eq..false. .or. b.eq..true.)) then
  325. C        print *,'Representation check:  '
  326. C        print *,'         b matches neither .true. nor .false.'
  327. C      endif
  328. C      print *,' '
  329.  
  330.       return
  331.       end
  332.  
  333.  
  334.       subroutine fstrtok()
  335.       character*70 cstrtok, a
  336.  
  337. C Setting up a NULL as :  i)  NUL character.
  338. C                         ii) NULL pointer.
  339.       character*4 NULL
  340.       NULL = CHAR(0)//CHAR(0)//CHAR(0)//CHAR(0)
  341.  
  342. C NUL in a forces cfortran.h to pass a, not a copy as usual.
  343.       data a/'first+second-third+forth-fifth-sixth seventh'/
  344.       a(70:) = NULL
  345.  
  346. C String until the first '-', then until the first '+'.
  347.       print *,cstrtok(a,    '-')
  348.       print *,cstrtok(NULL, '+')
  349.  
  350. C Flush the rest of the string.
  351. C Recall cfortran.h kills all trailing blanks. i.e. FORTRAN ' ' -> C "".
  352.       print *,cstrtok(NULL, ' ')
  353.  
  354. C Further calls return nothing.
  355.       print *,cstrtok(NULL, ' ')
  356.  
  357.       return
  358.       end
  359.